home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / COMAL / Z-Misc Series / (k)zd.d64 / src.calc < prev    next >
Text File  |  2007-03-01  |  3KB  |  150 lines
  1. ;
  2. ;--------------------------------;
  3. ;CALC - A COMAL MODULE           ;
  4. ;       EXTENDING COMAL-80 WITH  ;
  5. ;       FUNC HEX$(N), 0<=N<=255  ;
  6. ;                                ;
  7. ;BY DICK KLINGENS                ;
  8. ;DUTCH COMAL80 USERS GROUP       ;
  9. ;OKT 1985                        ;
  10. ;--------------------------------;
  11. ;
  12. * = $BF00
  13. ;--------------------- CONSTANTS
  14. ;
  15. FUNC = 227
  16. ENDFNC = 126
  17. INT = 1
  18. STR = 2
  19. VALUE = 114
  20. DEFPAG = %01000110
  21. ;--------------------- ROUTINES
  22. ;
  23. FNDPAR = $C896
  24. RUNERR = $C9FB
  25. DUMMY = $CA2F
  26. ;--------------------- VARIABLES
  27. ;
  28. COPY1 = $0045
  29. ANT = $0055
  30. STOS = $002D
  31. SFREE = $002F
  32. ;--------------------- MODULE
  33. ;
  34.  .BYTE DEFPAG
  35.  .WORD LEIND
  36.  .WORD DUMMY
  37.  .BYTE 7,'CALCHEX'
  38.  .WORD PROCT
  39.  .WORD DUMMY
  40.  .BYTE 0
  41. ;
  42. PROCT .BYTE 3,'HEX'
  43.  .WORD HHEX
  44.  .BYTE 0
  45. ;
  46. HHEX .BYTE FUNC+STR,<MAIN,>MAIN,1
  47.  .BYTE VALUE+INT
  48.  .BYTE ENDFNC
  49. ;--------------------- PROCEDURE BODY
  50. ;
  51. ;    ;                  PROC MAIN
  52. MAIN LDA #2   ; ANT:=2 //LENGTH
  53.  STA ANT
  54.  LDA #0
  55.  STA ANT+1
  56.  JSR TEST ; EXEC TEST
  57.  JSR CNVRT    ; EXEC CNVRT
  58.  JSR STROK    ; EXEC STROK
  59.  RTS          ;ENDPROC MAIN
  60. ;
  61. ; TEST IF THERE ROOM ON COMAL STACK
  62. ;
  63. ;      ;                PROC TEST
  64. TEST CLC      ; CARRY:=0
  65.  LDA ANT      ; .A:=LO ANT
  66.  ADC STOS     ; .A:+STOS
  67.  TAX          ; .X:=LO ANT+STOS
  68.  LDA ANT+1    ; .A:=HI ANT
  69.  ADC STOS+1   ; .A:=HI STOS
  70.  BCS STERR    ; IF CARRY THEN GOTO STERR
  71.  TAY          ; .Y:=.A
  72.  TXA          ; .A:=.X //NOW .A=LO ANT+STOS
  73.  ADC #<2      ; .A:+2 //LENGTH
  74.        TAX             ; .X:=.A
  75.  TYA
  76.  ADC #>2
  77.        BCS STERR       ; IF CARRY THEN GOTO STERR
  78.        CPX SFREE       ; IF ANT+STOS>SFREE THEN
  79.  SBC SFREE+1
  80.        BCS STERR       ;  GOTO STERR
  81.        RTS             ;ENDPROC TEST
  82. ;
  83. STERR     LDX #56
  84.  JMP RUNERR
  85. ;
  86. ; CONVERT TO HEX$
  87. ;
  88. ;      ;                PROC CNVRT
  89. CNVRT LDA #1   ; .A:=1 //FIRST PARAM
  90.  JSR FNDPAR    ; COPY1:=ADDRESS
  91.  LDY #0
  92.  LDA (COPY1),Y ; .A:=COPY1
  93.  BNE ARGERR    ; IF .A<>0 THEN GOTO ARGERR
  94.        INY             ; .Y:+1
  95.  LDA (COPY1),Y ; .A:=(COPY1+Y)
  96.  JSR TOHEX     ; EXEC TOHEX
  97.  RTS           ;ENDPROC CNVRT
  98. ;
  99. ARGERR  LDX #1
  100.  JMP RUNERR
  101. ;
  102. ;      ;                PROC TOHEX
  103. TOHEX  PHA             ; STACK:=.A
  104.        LSR A           ; LOGICAL SHIFT RIGHT
  105.  LSR A
  106.  LSR A
  107.  LSR A
  108.        JSR HEX         ; EXEC HEX
  109.        PLA             ; .A:=STACK
  110.        AND #15         ; .A:=.A BITAND 15
  111.        JSR HEX         ; EXEC HEX
  112.        RTS             ;ENDPROC HEX
  113. ;
  114. ;      ;                PROC HEX
  115. HEX    CMP #10         ; IF .A<10 THEN
  116.        BCC OFSET       ;  GOTO OFSET
  117.        CLC             ; CARRY:=0
  118.        ADC #7          ; .A:+7
  119. ;
  120. OFSET  ADC #'0         ; .A:+ORD("0")
  121. ;      ;                 //CHAR TO STACK
  122.        LDY #0          ; .Y:=0
  123.        STA (STOS),Y    ; .A:=(STOS+Y)
  124.        INC STOS        ; STOS:+1
  125.        BNE OK          ; IF STOS<>0 THEN GOTO OK
  126.        INC STOS+1      ; ELSE (STOS+1):+1
  127. ;
  128. OK     RTS             ;ENDPROC HEX
  129. ;
  130. ; LENGTH ON STACK AND
  131. ; CHANGE OF STACK POINTER
  132. ;
  133. ;      ;                PROC STROK
  134. STROK  LDY #0          ; .Y:=0
  135.        LDA ANT+1
  136.        STA (STOS),Y    ; (STOS+Y):=.A
  137.        INY             ; .Y:+1
  138.        LDA ANT         ; .A:=LO ANT
  139.        STA (STOS),Y    ; (STOS+Y):=.A
  140.        CLC             ; CARRY:=0
  141.        LDA STOS        ; .A:=LO STOS
  142.  ADC #<2
  143.        STA STOS        ; STOS:=.A
  144.        LDA STOS+1      ; .A:=HI STOS
  145.        ADC #>2         ; .A:+0
  146.        STA STOS+1      ; (STOS+1):=.A
  147.        RTS             ;ENDPROC STROK
  148. ;
  149. LEIND  .END            ;// END MODULE
  150.